PD ROM 1/PD ROM Volume I - Macintosh Software from BMUG (1988).iso/Graphics/Graphic Demos/Circles/Circles.Pas

Pascal/Delphi Source File | 1986-09-03 | 21.2 KB | 841 lines | [TEXT/ttxt]

PROGRAM Circles;

     {$I 'Pascal Complete:Pascal System:MemTypes.IPas' }
                                {basic Memory Manager data types}
     {$I 'Pascal Complete:Pascal System:QuickDraw.IPas'}
                                {interface to QuickDraw}
     {$I 'Pascal Complete:Pascal System:OSIntf.IPas'   }
                                {interface to the Operating System}
     {$I 'Pascal Complete:Pascal System:ToolIntf.IPas' }
                                {interface to the Toolbox}
     {$I 'Pascal Complete:Pascal System:PackIntf.IPas' }
                                {other packages}

     {$L Circles.rsrc }         {link in resources}
     {$B+}                      {set bundle bit}
     {$T 'APPL' 'TCIR'}         {set type and creator}

CONST
      myAppType = 'TCIR';
      myFType = 'CIRF';
      RDdoc = 8;

      appleID = 128;     {resource IDs/menu IDs for menus}
      fileID  = 129;
      editID  = 130;
      ControlID = 131;

      appleM = 1;        {index for each menu in myMenus (array of menu handles)}
      fileM  = 2;
      editM  = 3;
      ControlM = 4;

      menuCount = 4;     {total number of menus}

      windowID = 128;    {resource ID for main window}

      NewCom = 1;
      OpenCom = 2;
      CloseCom = 3;
      SaveCom = 4;
      SaveAsCom = 5;
      RevertCom = 6;
      QuitCom = 7;        {constants identifying commands in file menu}

      undoCommand  = 1;
      {blank item 2}
      cutCommand   = 3;
      copyCommand  = 4;
      pasteCommand = 5;
      clearCommand = 6;
      {blank item 7}
      CdiagCommand = 8;       {constants identifying commands in Edit menu}

      NCom = 1;       {constants identifying commands in Control menu}

      StringsID = 256;  {string resource containing misc. strings}
      getDID = 258;     {dialog ID for getting rows and columns}
      ErStopID = 256;   {stop alert: disc error}
      RevCauID = 257;   {caution alert: revert to saved}
      SaveCauID = 259;  {caution alert: save changes}



VAR myMenus: ARRAY[1..menuCount] OF MenuHandle; {array of handles to the menus}
    dragRect: Rect;         {rectangle used to mark boundaries for dragging window}
    theChar: CHAR;          {character typed on the keyboard or keypad}
    doneFlag: BOOLEAN;      {TRUE if user has chosen Quit command}
    myEvent: EventRecord;   {information about an event}
    RDWRecord: WindowRecord;  {information about the main window}
    RDWind: WindowPtr;        {pointer to RDWRecord of RD window}
    RDconWRecord: WindowRecord;  {information about the RD controls window}
    RDconW: WindowPtr;           {pointer to RDconWRecord of control window}
    whichWindow: WindowPtr; {pointer to window in which mouse button was pressed}
    hCurs: CursHandle;      {temp cursor handle}
    iBeam: Cursor;          {I-beam cursor (from resource file)}
    extended: BOOLEAN;      {TRUE if user is Shift-clicking}
    linteger: LONGINT;      {temporary longints}
    tempWPeek: WindowPeek;  {temporary windowpeeks}


    i: INTEGER;             {junk integers}
    TempRect: Rect;         {junk rectangles}
    tempStr,bugStr: Str255;
    mousePt : Point;
    SavePort: GrafPtr;     {temporary save of grafport}
    myPict: PicHandle;      {picture to be copied to scrap}

    UpdateFlag: BOOLEAN;


 FileVolume: INTEGER;    {which volume, if loaded from disk}
 changed: BOOLEAN;       {the document is 'dirty'}
 titled:  BOOLEAN;       {the document has been saved to disk}
 ErrorFlag, FCancel: BOOLEAN;
 MyFileTypes: SFTypeList;  {same as myFType, in a format for Standard File}

PROCEDURE doSave; FORWARD;
PROCEDURE RedrawWindow; FORWARD;


{----------------------------------------------------------------------------------}
PROCEDURE debug(pname: str255);
  BEGIN
  setRect(tempRect,10,278,200,292);
  eraseRect(tempRect);
  MoveTo(10,290);
  drawString(pname);
  END;


{----------------------------------------------------------------------------------}
PROCEDURE SetUpMenus;
{ Set up menus and menu bar }

  VAR i: INTEGER;

  BEGIN
  { Read menu descriptions from resource file into memory and store handles }
  { in myMenus array }
  myMenus[appleM] := GetMenu(appleID); {read Apple menu from resource file}
  AddResMenu(myMenus[appleM],'DRVR');  {add desk accessory names to Apple menu}
  myMenus[fileM] := GetMenu(fileID);   {read File menu from resource file}
  myMenus[editM] := GetMenu(editID);   {read Edit menu from resource file}
  myMenus[controlM] := GetMenu(controlID);   {read Edit menu from resource file}

  FOR i:=1 TO menuCount DO InsertMenu(myMenus[i],0);  {install menus in menu bar }
                                                      { and draw menu bar}
  DrawMenuBar;
  END;    {of SetUpMenus}




{----------------------------------------------------------------------------------}
{file handling routines follow...}


{------------------------------------------------------------------------------------}
PROCEDURE CloseAWindow;
BEGIN
  EraseRect(RDWind^.PortRect);
  UpdateFlag := FALSE;
END;

{------------------------------------------------------------------------------------}
PROCEDURE ExpandRD;
BEGIN
END;

{------------------------------------------------------------------------------------}
PROCEDURE DiskWErr (io : INTEGER);
VAR
    str:str255;
    writetostr, savedstr, str1, fName: Str255;
    dummy, errstr: INTEGER;

BEGIN
  GetIndString (writetostr,StringsID,10); {read resource for writeto}
  GetIndString (savedstr,StringsID,12);   {read resource for saved}
  errstr := 0;
  CASE io OF
    DskFulErr : errstr := 17;
    DirFulErr : errstr := 18;
    FLckdErr : errstr := 19;
    VLckdErr, WPrErr : errstr := 20;
    IOErr : errstr := 21;
    OTHERWISE
    BEGIN
      NumToString (io, str);
      GetIndString (str1,StringsID,22);{ID = }
      str := Concat (str1,str)
    END
  END;
  IF errstr <> 0 THEN GetIndString (str,StringsID,errstr);
  GetWTitle(RDWind,fName);
  Paramtext (writetostr,fName,savedstr,str);
  dummy := StopAlert (ErStopID, NIL);

  ErrorFlag := TRUE;
  doneFlag := FALSE;
END;


{------------------------------------------------------------------------------------}
Procedure DiskRErr (io : INTEGER);
VAR
    str: str255;
    readfromstr, loadedstr, str1, fName: Str255;
    dummy: INTEGER;

BEGIN
  GetIndString (readfromstr, StringsID, 9); {this says 'reading from'}
  GetIndString (loadedstr ,StringsID, 11); {this says 'loaded'}
  IF io = IOErr THEN
    GetIndString (str, StringsID, 21)  {this says 'IO error'}
  ELSE
    BEGIN
    NumToString (io, str1);
    GetIndString (str, StringsID, 22); {this is the generic 'ID ='}
    str := Concat (str, str1)
    END;
  GetWTitle(RDWind,fName);
  Paramtext (readfromstr, fName, loadedstr, str);
  dummy := StopAlert (ErStopID, NIL); {discribe error to user in generic way.}

  ErrorFlag := TRUE;
  doneFlag := FALSE;
END;



{------------------------------------------------------------------------------------}
PROCEDURE ReadFile (FName: Str255; VRefNum: INTEGER);
VAR io : INTEGER;
    logEOF: LongInt;
    RefNo: INTEGER;
    errin: str255;
    tempSize: LongInt;

BEGIN
  io := FSOpen (Fname, VRefNum, RefNo);
  IF io <> 0 THEN DiskRErr (io);

  IF NOT ErrorFlag THEN
    BEGIN
    io := GetEOF (RefNo, logEOF);
    IF io <> 0 THEN DiskRErr (io);
    END;

    {add code here:  if file is too large, then notify user and truncate}

 {
  IF NOT ErrorFlag THEN
    BEGIN
    tempSize := SIZEOF(mz);
    io := FSRead (refNo, tempSize, POINTER(@mz));
    IF io <> 0 THEN DiskRErr (io);
    END;

  IF NOT ErrorFlag THEN
    BEGIN
    tempSize := SIZEOF(nz);
    io := FSRead (refNo, tempSize, POINTER(@nz));
    IF io <> 0 THEN DiskRErr (io);
    END;

  IF NOT ErrorFlag THEN
    BEGIN
    tempSize := SIZEOF(brd);
    io := FSRead (refNo, tempSize, POINTER(@brd));
    IF io <> 0 THEN DiskRErr (io);
    END;
 }
  io := FSClose (refNo);
  IF NOT ErrorFlag THEN
    IF io <> 0 THEN DiskRErr (io);

  IF NOT ErrorFlag THEN
    ExpandRD;

  IF NOT ErrorFlag THEN
    changed := FALSE;

  SetCursor (Arrow);
END;


{------------------------------------------------------------------------------------}
PROCEDURE WriteFile (fName : str255; vRefNum: INTEGER);
VAR refNo, io : INTEGER;
    fileLength: LongInt;
    tempSize: LongInt;

BEGIN
  io := FSOpen(fName, VRefNum, refNo);            {Try to open file}

  IF io = {file not found Err} -43 THEN {create new fule}
    BEGIN
    io := Create (FName,VRefNum,myAppType,myFType);
    IF io <> 0 THEN
      DiskWErr (io);

    IF NOT ErrorFlag THEN
      BEGIN
      io := FSOpen(fName, VRefNum, refNo);
      IF io <> 0 THEN DiskWErr (io)
      END;

    END; {Create}

 {
  fileLength := SizeOf(brd);

  IF NOT ErrorFlag THEN
    BEGIN
    io := SetEOF (refNo, 0);
    IF io <> 0 THEN DiskWErr (io);
    END;

  IF NOT ErrorFlag THEN
    BEGIN
    tempSize := SIZEOF(mz);
    io := FSWrite (refNo, tempSize, POINTER(@mz));
    IF io <> 0 THEN DiskWErr (io);
    END;

  IF NOT ErrorFlag THEN
    BEGIN
    tempSize := SIZEOF(nz);
    io := FSWrite (refNo, tempSize, POINTER(@nz));
    IF io <> 0 THEN DiskWErr (io);
    END;

  IF NOT ErrorFlag THEN
    BEGIN
    tempSize := SIZEOF(brd);
    io := FSWrite (refNo, tempSize, POINTER(@brd));
    IF io <> 0 THEN DiskWErr (io);
    END;
 }
  io := FSClose (refNo);
  If NOT ErrorFlag THEN
    IF io <> 0 THEN DiskWErr (io);

  io := FlushVol (NIL, VrefNum);
  IF NOT ErrorFlag THEN
    IF io <> 0 THEN DiskWErr (io);

  IF NOT ErrorFlag THEN
    changed := FALSE;

  SetCursor (Arrow);
END;


{----------------------------------------------------------------------------------}
PROCEDURE CloseSysWindow;

VAR
  WhichWindow: WindowPeek;
  accNumber: INTEGER;

BEGIN
  whichWindow := WindowPeek(FrontWindow);
  accNumber := whichWindow^.windowKind;
  CloseDeskAcc(accNumber);
END;


{----------------------------------------------------------------------------------}
PROCEDURE OpenAFile(FileName: Str255; VolRefNum: INTEGER);
VAR
  i: INTEGER;

BEGIN
  IF NOT FCancel THEN
    BEGIN
    ReadFile(FileName,VolRefNum);
    IF NOT ErrorFlag THEN
      BEGIN
      titled := TRUE;
      changed := FALSE;
      FileVolume := VolRefNum;
      SetWTitle(RDWind,FileName);
      END
    ELSE
      BEGIN
      titled := FALSE;
      changed := TRUE;
      FCancel := TRUE;
      END;
    END; {not cancel}
END;



{----------------------------------------------------------------------------------}
PROCEDURE doSaveAs;
VAR
   tempPt: Point;      {origin for putfile dialog}
   theReply: SFReply;  {answer from putfile}
   NameStr: Str255;    {prompt for putfile}
   OldName: Str255;    {the old name of the file}


BEGIN
  GetWTitle(RDWind,OldName);
  GetIndString (NameStr,StringsID,2); {"save file as"}
  SetPt(tempPt,100,100);
  SFPutFile (tempPt, NameStr, OldName, NIL, theReply);

  WITH theReply DO
    IF good THEN
      BEGIN
      titled := TRUE;
      Changed := TRUE;
      FileVolume := vRefNum;
      SetWTitle(RDWind,fName);
      doSave;
      END
    ELSE
      BEGIN
      FCancel := TRUE;
      doneFlag := FALSE;
      END;
END;



{----------------------------------------------------------------------------------}
PROCEDURE doSave;
VAR
  FileName: Str255;

BEGIN
  IF titled THEN
    BEGIN
    GetWTitle(RDWind,FileName);
    WriteFile(FileName,FileVolume);
    END
  ELSE
    doSaveAs;
END;


{----------------------------------------------------------------------------------}
PROCEDURE doRevert;
VAR FileName: Str255;

BEGIN
  IF titled THEN
    BEGIN
    GetWTitle(RDWind,FileName);
    IF NOT changed THEN             {titled but not changed, just reread}
      ReadFile(FileName,FileVolume)
    ELSE
      BEGIN
      IF CautionAlert(RevCauID, NIL) = OK THEN {titled and changed, ask if forget changes}
        ReadFile(FileName,FileVolume);
      END;
    RedrawWindow;
    Changed := TRUE;
    END;
END;


{----------------------------------------------------------------------------------}
PROCEDURE doClose;
CONST
  NoSave = 3;
VAR
  FileName,qStr: Str255;

BEGIN
  IF changed THEN
    BEGIN
    GetWTitle(RDWind,FileName);
    IF doneFlag THEN
      GetIndString (qStr,StringsID,8)
    ELSE
      qStr := '';
    ParamText (FileName,qStr,'','');
    CASE CautionAlert(SaveCauID, NIL) OF
      OK:
        BEGIN
        doSave;
        IF NOT FCancel THEN
          CloseAWindow;
        END;

      Cancel:
        BEGIN
        FCancel := TRUE;
        doneFlag := FALSE;
        END;

      NoSave:
        CloseAWindow;
      END; {CASE}
    END
  ELSE
    CloseAWindow;
END;


{----------------------------------------------------------------------------------}
PROCEDURE doNew;
VAR nameStr: Str255;

BEGIN
  titled := FALSE;
  changed := FALSE;
  GetIndString (NameStr,StringsID,1); {"Untitled"}
  SetWTitle(RDWind,NameStr);

  UpdateFlag := FALSE;
  UpdateFlag := TRUE;
END;


{----------------------------------------------------------------------------------}
PROCEDURE doOpen;
{opens file from disk}

VAR
   tempPt: Point;
   theReply: SFReply;

BEGIN
  IF changed THEN
    doClose;

  IF NOT FCancel THEN
    BEGIN
    SetPt(tempPt,90,100);
    SFGetFile(tempPt,'',NIL,1,MyFileTypes,NIL,theReply);
    WITH theReply DO
      IF good THEN
        OpenAFile(fName,vRefNum);
    END;
END;

{----------------------------------------------------------------------------------}
PROCEDURE doQuit;
BEGIN
  doneFlag := TRUE;
  doClose
END;


{----------------------------------------------------------------------------------}
PROCEDURE OpenFiles;
{Open files initially selected from Finder, or a blank one if none are selected}
VAR
   numFiles: INTEGER;
   message: INTEGER;
   document : appFile;
   counter: INTEGER;

BEGIN
  CountAppFiles(message, numfiles);     {get number of files to be opened}

  FCancel := FALSE;
  IF numFiles = 0 THEN
    doNew
  ELSE
    BEGIN
    GetAppFiles (1, document);
    WITH document DO
      IF ftype = myFileTypes[0] THEN
        OpenAFile(fName,vRefNum);
    END;
END;



{real program follows}

PROCEDURE CirClick(cPoint: Point);
VAR
  il,jl,endR: LongInt;
  rPoint,ePoint: Point;
  spacing: INTEGER;
  lwidth: INTEGER;
  lPos,rPos,uPos,dPos: INTEGER;
BEGIN
  REPEAT UNTIL NOT Button;
  GetMouse(rPoint);
  il := rPoint.h-cPoint.h;
  jl := rPoint.v-cPoint.v;
  spacing := Trunc(0.5+Sqrt(il*il +jl*jl));
  lwidth := spacing DIV 2;
  IF lwidth <= 0 THEN
    lwidth := 1;
  IF spacing <= 0 THEN
    spacing := 1;
  Pensize(lwidth,lwidth);
  Penmode(patXOr);
  PenPat(black);
  lPos := cPoint.h - spacing;
  rPos := cPoint.h + spacing;
  uPos := cPoint.v - spacing;
  dPos := cPoint.v + spacing;
  SetRect(tempRect,lPos,uPos,rPos,dPos);
  FrameOval(tempRect);
  REPEAT UNTIL GetNextEvent(mDownMask,myEvent);
  ePoint := myEvent.where;
  GlobaltoLocal(ePoint);
  il := ePoint.h-cPoint.h;
  jl := ePoint.v-cPoint.v;
  endR := Trunc(0.5+Sqrt(il*il +jl*jl));
  REPEAT
    lPos := lPos - spacing;
    rPos := rPos + spacing;
    uPos := uPos - spacing;
    dPos := dPos + spacing;
    SetRect(tempRect,lPos,uPos,rPos,dPos);
    FrameOval(tempRect);
  UNTIL (dPos-rPoint.v+lwidth) >= endR;
END;



PROCEDURE InitProgram;
VAR iz, jz: INTEGER;

BEGIN
 SetRect(TempRect,0,0,511,342);
 EraseRect(TempRect);                  {clear screan}
END; {InitProgram}


PROCEDURE FinishOff;
BEGIN
END; {FinishOff Procedure}



PROCEDURE ReplotStructure(OffSet: INTEGER);
BEGIN
END;

PROCEDURE RedrawWindow;
BEGIN
  EraseRect(RDWind^.PortRect);
  ReplotStructure(0);
END;

{----------------------------------------------------------------------------------}
PROCEDURE DoCommand (mResult: LONGINT);
{ Execute command specified by mResult, the result of MenuSelect }

  VAR theItem: INTEGER;  {menu item number from mResult low-order word}
      theMenu: INTEGER;  {menu number from mResult high-order word}
      name: Str255;      {desk accessory name}
      temp: INTEGER;
      savePort: GrafPtr;      {temporary save of grafport}


  BEGIN {PROCEDURE DoCommand}
  theItem := LoWord(mResult);
  theMenu := HiWord(mResult);             {set menu item number and menu number}

  CASE theMenu OF                         {case on menu ID}

  appleID:
    BEGIN
    GetItem(myMenus[appleM],theItem,name);  {get name of desk accesory}
    GetPort(SavePort);
    temp := OpenDeskAcc(name);              {open desk accesory}
    SetPort(SavePort);
    END;    {of appleID}

  fileID:
    BEGIN
    FCancel := FALSE;

    CASE theItem OF
      NewCom: doNew;

      OpenCom: doOpen;

      CloseCom:
        BEGIN
        tempWPeek := WindowPeek(FrontWindow);
        IF tempWPeek^.WindowKind = RDdoc THEN
          doClose
        ELSE
          CloseSysWindow;
        END;

      SaveCom:
        BEGIN
        tempWPeek := WindowPeek(FrontWindow);
        IF tempWPeek^.WindowKind = RDdoc THEN
          doSave;
        END;

      SaveAsCom:
        BEGIN
        tempWPeek := WindowPeek(FrontWindow);
        IF tempWPeek^.WindowKind = RDdoc THEN
          doSaveAs;
        END;

      RevertCom:
        BEGIN
        tempWPeek := WindowPeek(FrontWindow);
        IF tempWPeek^.WindowKind = RDdoc THEN
          doRevert;
        END;

      QuitCom: doQuit;

      END; {case on theItem}

    END; {case of FileID}

  editID:
    BEGIN                         {call Desk Manager to handle editing command if }
    IF NOT SystemEdit(theItem-1) THEN  {desk accessory window is the active window}
                                       {application window is the active window}
      BEGIN

      IF theItem = CdiagCommand THEN
        BEGIN

        myPict := OpenPicture(RDWind^.PortRect);
        ReplotStructure(1);
        ClosePicture;

        linteger := ZeroScrap;
        linteger := PutScrap(myPict^^.picSize,'PICT',POINTER(myPict^));
        END

      END
    END;

  controlID:
    CASE theItem OF
    NCom:
         BEGIN
     EraseRect(RDWind^.PortRect);
         END;
    END;

  END;    {of menu case}          {to indicate completion of command, call }
  HiliteMenu(0);                  {Menu Manager to unhighlight menu title  }
                                  {(highlighted by MenuSelect)             }
  END;  {of DoCommand}



{----------------------------------------------------------------------------------}
PROCEDURE MainLoop;

  BEGIN

  SystemTask;                             {do desk accessories}

  IF GetNextEvent(everyEvent,myEvent) {call Toolbox Event Manager to get the next }
    THEN                              { event that the application should handle}
      CASE myEvent.what OF            {case on event type}

      mouseDown:            {mouse button down:  call Window Manager to learn where}
        CASE FindWindow(myEvent.where,whichWindow) OF

        inSysWindow:        {desk accessory window: call Desk Manager to handle it}
          SystemClick(myEvent,whichWindow);

        inMenuBar:          {menu bar:  call Menu Manager to learn which command; }
          DoCommand(MenuSelect(myEvent.where)); { then execute it}

        inContent:
          BEGIN
          IF whichWindow <> FrontWindow THEN
            SelectWindow(whichWindow)
          ELSE
            BEGIN
            GlobalToLocal(myEvent.where);
            CirClick(myEvent.where)
            END;
          END     {of inContent}

        END;    {of mouseDown}

     keyDown, autoKey:              {key pressed once or held down to repeat}
        BEGIN
        theChar := CHR(BitAnd(myEvent.message,charCodeMask));  {get the character}
        IF BitAnd(myEvent.modifiers,cmdKey) <> 0  THEN { if Command key down,    }
          DoCommand(MenuKey(theChar))                  { execute it              }
        ELSE
          BEGIN
          END;
        END;

      activateEvt:
      BEGIN
      IF BitAnd(myEvent.modifiers,activeFlag) <> 0 THEN   {window becoming active}
        IF myEvent.message = Ord4(RDWind) THEN
          BEGIN
          SelectWindow(RDWind);
          SetPort(RDWind);
          END
        ELSE
          BEGIN                  {application window is becoming inactive: }
          END;
      END;   {of activateEvt}

      updateEvt:
        BEGIN
        GetPort(savePort);
        SetPort(RDWind);
        BeginUpdate(RDWind);
        IF UpdateFlag Then
          ReplotStructure(0);
        EndUpdate(RDWind);
        SetPort(savePort);
        END

     END;    {of event case}

END; {main loop}



BEGIN  {C_S_Cover}
{ Initialization }
InitGraf(@thePort);           {initialize QuickDraw}
InitFonts;                    {initialize Font Manager}
FlushEvents(everyEvent,0);    {call OS Event Manager to discard any previous events}
InitWindows;                  {initialize Window Manager}
InitMenus;                    {initialize Menu Manager}
TEInit;                       {initialize TextEdit}
InitDialogs(NIL);             {initialize Dialog Manager}
InitCursor;                   {call QuickDraw to make cursor (pointer) an arrow}

SetUpMenus;                   {set up menus and menu bar}

WITH screenBits.bounds DO     {call QuickDraw to set dragging boundaries; ensure at }
  SetRect(dragRect,4,24,right-4,bottom-4); { least 4 by 4 pixels will remain visible}
doneFlag := FALSE;            {flag to detect when Quit command is chosen}

RDWind := GetNewWindow(windowID,@RDWRecord,POINTER(-1)); {put up RD window}

hCurs := GetCursor (iBeamCursor);
iBeam := hCurs^^;                              {get I-beam cursor}

SelectWindow(RDWind);
SetPort(RDWind);
tempWPeek := WindowPeek(RDWind);
tempWPeek^.windowkind := RDdoc;
myFileTypes[0] := myFType;

UpDateFlag := FALSE;

 REPEAT
   MainLoop;
 UNTIL doneFlag;
END.